home *** CD-ROM | disk | FTP | other *** search
/ MacAddict 84 / MacAddict_084_2003_08.iso / pc / Software / Audio & Music / Audacity 1.1.3.dmg / nyquist / seqmidi.lsp < prev    next >
Lisp/Scheme  |  2002-09-16  |  6KB  |  160 lines
  1. ;; seqmidi.lsp -- functions to use MIDI files in Nyquist
  2. ;
  3. ; example call:
  4. ; 
  5. ; (seq-midi my-seq
  6. ;   (note (chan pitch velocity) (= chan 2) (my-note pitch velocity))
  7. ;   (ctrl (chan control value) (...))
  8. ;   (bend (chan value) (...))
  9. ;   (touch (chan value) (...))
  10. ;   (prgm (chan value) (setf (aref my-prgm chan) value))
  11.  
  12. ;; seq-midi - a macro to create a sequence of sounds based on midi file
  13. ;
  14. ; 
  15. (defmacro seq-midi (the-seq &rest cases)
  16.   (seq-midi-cases-syntax-check cases)
  17.   `(let (_the-event _next-time _the-seq _seq-midi-closure _nyq-environment 
  18.          _the-seq _tag)
  19.     (setf _the-seq (seq-copy ,the-seq))
  20.     (setf _nyq-environment (nyq:the-environment))
  21.     (setf _seq-midi-closure #'(lambda (t0)
  22.       ; (format t "_seq_midi_closure: t0 = ~A~%" t0)
  23.       (prog (_the-sound)
  24. loop    ; go forward until we find note to play (we may be there)
  25.         ; then go forward to find time of next note
  26.         (setf _the-event (seq-get _the-seq))
  27.         ; (display "seq-midi" _the-event t0)
  28.         (setf _tag (seq-tag _the-event))
  29.         (cond ((= _tag seq-ctrl-tag)
  30.                ,(make-ctrl-handler cases))
  31.               ((= _tag seq-bend-tag)
  32.                ,(make-bend-handler cases))
  33.               ((= _tag seq-touch-tag)
  34.                ,(make-touch-handler cases))
  35.               ((= _tag seq-prgm-tag)
  36.                ,(make-prgm-handler cases))
  37.               ((= _tag seq-done-tag)
  38.                ; (format t "_seq_midi_closure: seq-done")
  39.                (cond (_the-sound ; this is the last sound of sequence
  40.                       ; (format t "returning _the-sound~%")
  41.                       (return _the-sound))
  42.                      (t ; sequence is empty, return silence
  43.                       ; (format t "returning snd-zero~%")
  44.                       (return (snd-zero t0 *sound-srate*)))))
  45.               ((and (= _tag seq-note-tag)
  46.                     ,(make-note-test cases))
  47.                (cond (_the-sound ; we now have time of next note
  48.                       (setf _next-time (/ (seq-time _the-event) 1000.0))
  49.                       (go exit-loop))
  50.                      (t
  51.                       (setf _the-sound ,(make-note-handler cases))))))
  52.         (seq-next _the-seq)
  53.         (go loop)
  54. exit-loop ; here, we know time of next note
  55.         ; (display "seq-midi" _next-time)
  56.         ; (format t "seq-midi calling snd-seq\n")
  57.         (return (snd-seq
  58.                   (set-logical-stop-abs _the-sound 
  59.                         (local-to-global _next-time))
  60.                   _seq-midi-closure)))))
  61.     ; (display "calling closure" (get-lambda-expression _seq-midi-closure))
  62.     (funcall _seq-midi-closure (local-to-global 0))))
  63.  
  64.  
  65. (defun seq-midi-cases-syntax-check (cases &aux n)
  66.   (cond ((not (listp cases))
  67.          (break "syntax error in" cases)))
  68.   (dolist (case cases)
  69.     (cond ((or (not (listp case)) 
  70.                (not (member (car case) '(NOTE CTRL BEND TOUCH PRGM)))
  71.                (not (listp (cdr case)))
  72.                (not (listp (cadr case)))
  73.                (not (listp (cddr case)))
  74.                (not (listp (last (cddr case)))))
  75.            (break "syntax error in" case))
  76.           ((/= (length (cadr case))
  77.                (setf n (cdr (assoc (car case) 
  78.                              '((NOTE . 3) (CTRL . 3) (BEND . 2)
  79.                                (TOUCH . 2) (PRGM . 2))))))
  80.            (break (format nil "expecting ~A arguments in" n) case))
  81.           ((and (eq (car case) 'NOTE)
  82.                 (not (member (length (cddr case)) '(1 2))))
  83.            (break 
  84.             "note handler syntax is (NOTE (ch pitch vel) [filter] behavior)"
  85.             case)))))
  86.  
  87.  
  88. (defun make-ctrl-handler (cases)
  89.   (let ((case (assoc 'ctrl cases)))
  90.     (cond (case
  91.            `(let ((,(caadr case) (seq-channel _the-event))
  92.                   (,(cadadr case) (seq-control _the-event))
  93.                   (,(caddar (cdr case)) (seq-value _the-event)))
  94.               ,@(cddr case)))
  95.           (t nil))))
  96.  
  97. (defun make-bend-handler (cases)
  98.   (let ((case (assoc 'bend cases)))
  99.     (cond (case
  100.            `(let ((,(caadr case) (seq-channel _the-event))
  101.                   (,(cadadr case) (seq-value _the-event)))
  102.               ,@(cddr case)))
  103.           (t nil))))
  104.  
  105. (defun make-touch-handler (cases)
  106.   (let ((case (assoc 'touch cases)))
  107.     (cond (case
  108.            `(let ((,(caadr case) (seq-channel _the-event))
  109.                   (,(cadadr case) (seq-value _the-event)))
  110.               ,@(cddr case)))
  111.           (t nil))))
  112.  
  113. (defun make-prgm-handler (cases)
  114.   (let ((case (assoc 'pgrm cases)))
  115.     (cond (case
  116.            `(let ((,(caadr case) (seq-channel _the-event))
  117.                   (,(cadadr case) (seq-value _the-event)))
  118.               ,@(cddr case)))
  119.           (t nil))))
  120.  
  121. (defun make-note-test (cases)
  122.   (let ((case (assoc 'note cases)))
  123.     (cond ((and case (cdddr case))
  124.            (caddr case))
  125.           (t t))))
  126.            
  127.  
  128. (defun make-note-handler (cases)
  129.   (let ((case (assoc 'note cases))
  130.         behavior)
  131.     (cond ((and case (cdddr case))
  132.            (setf behavior (cadddr case)))
  133.           (t
  134.            (setf behavior (caddr case))))
  135.     `(with%environment _nyq-environment
  136.         (with-note-args ,(cadr case) _the-event ,behavior))))
  137.  
  138.  
  139. (defmacro with-note-args (note-args the-event note-behavior)
  140.   ; (display "with-note-args" the-event)
  141.   `(let ((,(car note-args) (seq-channel ,the-event))
  142.          (,(cadr note-args) (seq-pitch ,the-event))
  143.          (,(caddr note-args) (seq-velocity ,the-event)))
  144.      (at (/ (seq-time ,the-event) 1000.0)
  145.       (stretch (/ (seq-duration ,the-event) 1000.0) ,note-behavior))))
  146.  
  147.  
  148. ;(defun seq-next-note-time (the-seq find-first-flag)
  149. ;  (prog (event)
  150. ;    (if find-first-flag nil (seq-next the-seq))
  151. ;loop
  152. ;    (setf event (seq-get the-seq))
  153. ;    (cond ((eq (seq-tag event) seq-done-tag)
  154. ;       (return (if find-first-flag 0.0 nil)))
  155. ;      ((eq (seq-tag event) seq-note-tag)
  156. ;       (return (/ (seq-time event) 1000.0))))
  157. ;    (seq-next the-seq)
  158. ;    (go loop)))
  159. ; 
  160.